(in-package :tree-view)

(defvar *solution* nil)

(defstruct (multiparent-solution (:conc-name mps-))
  box pos)

(defstruct (info-pack (:conc-name ip-))
  diagram root
  ;; all boxes in the diagram
  boxes
  ;; all boxes being placed and ones that have already been placed
  ;;placees placed
  multiparents simple-multiparents
  x-boxes regulars leaves)

(defun find-multi-parent-boxes (tree)
  "find multi parent boxes that are entirely contained in tree. This
will always be true if TREE is the root of the diagram but not always
so if tree is a subtree.

This is useful when recursively placing multiparent boxes that have
multiparent descendants."
  (let (multis)
    (tree:with-iterator (iterate node recurse)
        (if (and (u:neq node tree)
                 (multiparent-box-p node))
            (when (every (lambda (p) (tree:descendant-p p tree)) (tree:parents node))
              (push node multis))
            (recurse))
      ;; body
      (iterate tree)
      multis)))

(defun find-x-boxes-without-mp-ancestors (tree)
  "Collect all X boxes but don't search deeper than any multi-parent boxes."
  (let (x)
    (tree:with-iterator (iterate node recurse)
        (if (typep node 'box)
            (unless (and (u:neq node tree)
                         (multiparent-box-p node))
              (if (and (xbox-p node) (single-parent-p node))
                  (push node x)
                  (recurse)))
            (recurse))
      ;; body
      (iterate tree)
      x)))

(defun all-boxes-up-to-mps (root)
  (let (acc)
    (tree:with-iterator (iterate node recurse 'box)
        (progn
          (push node acc)
          (unless (multiparent-box-p node)
            (recurse)))
      ;; body
      (iterate root)
      acc)))

(defun all-regular-boxes (root include-x-boxes)
  "Once we hit a multiparent box, we stop searching."
  (let (ret)
    (tree:with-iterator (iterate node recurse 'box)
        (when (or (eq node root)
                  (and (not (multiparent-box-p node))
                       (or include-x-boxes
                           (not (xbox-p node)))))
          (push node ret)
          (recurse))
      ;; body
      (iterate root)
      ret)))

(defun regular-box-leaves (tree)
  "Once we hit a multiparent box, we stop searching."
  (let (ret)
    (tree:with-iterator (iterate node recurse)
        (if (typep node 'box)
            (when (some (lambda (b)
                          (or (multiparent-box-p b)
                              (xbox-p b)))
                        (child-boxes node))
              (push node ret)
              (recurse))
            (recurse))
      ;; body
      (iterate tree)
      ret)))

(defun multibox-descendant-p (node mp-boxes)
  (some (u:curry tree:descendant-p node (b))
        mp-boxes))

(defun simple-multiparent-p (box mp-boxes)
  (and (multiparent-box-p box)
       (notany (u:curry multibox-descendant-p (a) mp-boxes)
               (tree:parents box))
       (let ((parents (remove-if (lambda (a)
                                   (some (u:curry tree:descendant-p a (b)) mp-boxes))
                                 (apply 'append (mapcar 'tree:parents (remove box mp-boxes))))))
         (multiple-value-bind (min max) (parent-arg-inner-flanks box)
           ;;(print `(smp ,(childq box) ,min ,max ,(mapcar 'geom:x parents)))
           (dolist (p parents) (setf (debug-text p) "smp"))
           ;; box's parents don't span any parent args
           (notany (lambda (a)
                     (< min (geom:x a) (geom:right a) max))
                   parents)))))

(defun gen-info-pack (root diagram)
  (let* ((boxes (all-boxes-up-to-mps root))
         (mps (delete root (u:collect-if 'multiparent-box-p boxes)))
         (spanners (collect-on-tree (lambda (b)
                                      (and (not (find b mps))
                                           (multiparent-box-p b)
                                           ;; this mp box must descend
                                           ;; from at least 2 "base"
                                           ;; mp boxes to
                                           ;; qualify. FIXME: this
                                           ;; code borks when an mp
                                           ;; box is completely
                                           ;; contained in an mp box
                                           ;; in mps that has a parent
                                           ;; box also in mps.
                                           (>= (length (u:collect-if (lambda (m) (tree:descendant-p b m)) mps))
                                               2)))
                                    root)))
    ;;(print `(span ,(mapcar 'childq spanners)))
    (setf boxes (append boxes spanners)
          mps (append mps spanners))
    ;;    (print `(simple ,(mapcar 'childq mps) ,(mapcar 'childq (delete root (u:collect-if (lambda (b) (simple-multiparent-p b mps)) boxes)))))
    (make-info-pack :diagram diagram
                    :root root
                    :boxes boxes
                    :multiparents mps
                    :simple-multiparents (delete root (u:collect-if (lambda (b) (simple-multiparent-p b mps)) boxes))
                    :x-boxes (u:collect-if (lambda (b) (and (single-parent-p b) (xbox-p b))) boxes)
                    :regulars (u:collect-if 'normal-box-p boxes)
                    :leaves (u:collect-if (lambda (b)
                                            (and (single-parent-p b)
                                                 (or (leaf-box-p b)
                                                     (every (lambda (b)
                                                              (or (multiparent-box-p b)
                                                                  (xbox-p b)))
                                                            (child-boxes b)))))
                                          boxes))))

(defun parent-box-flanks (box)
  (loop for i in (parent-boxes box)
     minimize (geom:x i) into min
     maximize (geom:right i) into max
     finally (return (values min max))))

(defun parent-arg-inner-flanks (box)
  "Return the inner corners of the outermost parents of BOX."
  (loop for i in (tree:parents box)
     minimize (geom:right i) into min
     maximize (geom:x i) into max
     finally (return (values min max))))

(defun parent-arg-outer-flanks (box)
  "Return the inner corners of the outermost parents of BOX."
  (loop for i in (tree:parents box)
     minimize (geom:right i) into min
     maximize (geom:x i) into max
     finally (return (values min max))))

(defun childq (box)
  (mapcar 'd:quantity (tree:children box)))

(defun get-multi-parent-places (box ip placed)
  (let ((mp-descendants (descendants-of box (ip-multiparents ip))))
    ;; Ensure that all descendant MPs are placed 
    (assert (every (lambda (b) (find b placed))
                   mp-descendants)
            () "not all descendants have been placed! ~a ~a" (childq box) (mapcar 'childq mp-descendants) (mapcar 'childq placed))
    (labels ((box-center (b)
               (+ (geom:x b) (u:half (geom:width b))))
             (center (x) (- x (u:half (geom:width box))))
             (on-left-side (box parent)
               (when (box-left-arg parent)
                 (find box (tree:children (box-left-arg parent)))))
             (on-right-side (box parent)
               (when (box-right-arg parent)
                 (find box (tree:children (box-right-arg parent)))))
             (right-child-boxes (parent)
               (tree:children (box-right-arg parent)))
             (left-child-boxes (parent)
               (tree:children (box-left-arg parent)))
             (boxes-max-depth (arg)
               (loop for i in (tree:children arg)
                  maximize (tree:depth i)))
             (all-placed (boxes)
               (null (set-difference boxes placed)))
             (all-below (boxes y)
               (every (lambda (b) (> (geom:y b) y)) boxes))
             (center-or-ofs (box y parent boxes ofs)
               (let ((center (geom:pt (center (box-center parent)) y)))
                 (if boxes
                     (if (all-placed boxes)
                         (if (all-below boxes y)
                             (list center)
                             (list ofs center))
                         (list ofs))
                     (list center))))
             (get-loc-for-parent (box parent miny)
               (let ((y (- (min miny (geom:y parent)) (geom:height box) (vpadding (ip-diagram ip)))))
                 (cond
                   ((on-left-side box parent)
                    ;;(print `(on-left ,(childq box) ,(childq parent) ,(mapcar 'childq (right-child-boxes parent)) ,(notany 'multiparent-box-p (right-child-boxes parent))))
                    (center-or-ofs box y parent (right-child-boxes parent) (geom:pt (- (box-center parent) (geom:width box) (u:half (hpadding (ip-diagram ip)))) y)))
                   ((on-right-side box parent)
                    ;;(print `(on-right ,(childq box) ,(childq parent) ,(mapcar 'childq (left-child-boxes parent)) ,(notany 'multiparent-box-p (left-child-boxes parent))))
                    (center-or-ofs box y parent (left-child-boxes parent) (geom:pt (+ (box-center parent) (u:half (hpadding (ip-diagram ip)))) y)))
                   (t
                    (list (geom:pt (center (box-center parent)) y)))))))
      (let ((miny (loop for i in (parent-boxes box)
                     minimize (geom:y i)))
            (children-of-placed (loop for i in placed
                                     append (collect-on-tree (complement 'multiparent-box-p) i))))
        (cond
          ((find box (ip-simple-multiparents ip))
           (get-loc-for-parent box (or
                                    ;; try to center things if possible
                                    (let ((mid (u:middle (sort (copy-list (parent-boxes box)) '< :key 'geom:centerx))))
                                      (when (null (remove box (child-boxes mid)))
                                        mid))
                                    (find-if (lambda (b)
                                               (null (remove box (child-boxes b))))
                                             (parent-boxes box))
                                    (first (parent-boxes box)))
                               miny))
          (t
           (remove-if
            (lambda (pt)
              (some (lambda (b)
                      (geom:overlap-p (geom:rect (geom:x pt) (geom:y pt)
                                                 (geom:width box) (geom:height box))
                                      b))
                    (append placed (ip-leaves ip) children-of-placed)))
            (multiple-value-bind (min max) (parent-arg-inner-flanks box)
              ;;(print `(doing ,(childq box)))
              (loop for i in (remove-duplicates (append placed (ip-leaves ip) (parent-boxes box)))
                 ;;do (print `(try ,(childq i)))
                 if (find i (parent-boxes box))
                 append (get-loc-for-parent box i miny)
                 else if (and (< min (geom:x i) (geom:right i) max)
                              (or (null (child-boxes i))
                                  (and (left-child-boxes i)
                                       (null (right-child-boxes i)))
                                  (and (right-child-boxes i)
                                       (null (left-child-boxes i))))
                              ;; (or (notany 'multiparent-box-p (child-boxes i))
;;                                   (every (lambda (b) (<= (tree:depth b) depth)) (child-boxes i)))
                              )
                 collect (geom:pt (cond
                                    ((null (child-boxes i))
                                     ;;(print `(none ,(childq i)))
                                     (center (box-center i)))
                                    ((left-child-boxes i)
                                     ;;(print `(left ,(childq i)))
                                     (+ (box-center i) (u:half (hpadding (ip-diagram ip)))))
                                    ((right-child-boxes i)
                                     ;;(print `(right ,(childq i)))
                                     (- (box-center i) (geom:width box) (u:half (hpadding (ip-diagram ip)))))
                                    (t (error "nowhere to put box??")))         
                                  (- (min miny (geom:y i)) (geom:height box) (vpadding (ip-diagram ip))))
                 ;; else do (print `(failed ,(childq i)
;;                                          ,(< min (geom:x i) (geom:right i) max)
;;                                          ,(notany 'multiparent-box-p (child-boxes i))
;;                                          ,(every (lambda (b) (<= (tree:depth b) depth)) (child-boxes i))))
                   )))))))))


;; (defstruct dammit
;;   item score after)

;; (defun dammit-sort (list fn)
;;   (let ((items (mapcar (lambda (a) (make-dammit :item a :score 0)) list)))
;;     (labels ((bump (record min done)
;;                (print `(bump! ,(childq (dammit-item record))))
;;                (when (find record done)
;;                  (error "circular reference in attempt to sort. Check your sort function."))
;;                (when (<= (dammit-score record) min)
;;                  (setf (dammit-score record) (1+ min))
;;                  (dolist (i (dammit-after record))
;;                    (bump i (dammit-score record) (cons record done))))))
;;       (loop for i in items
;;          do (print `(outter ,(childq (dammit-item i)))) (terpri)
;;            (loop for j in items
;;                do (print `(inner ,(childq (dammit-item j)))) (terpri)
;;                 (unless (eq j i)
;;                     (when (funcall fn (dammit-item i) (dammit-item j))
;;                       (print `(true ,(funcall fn (dammit-item i) (dammit-item j)) ,(childq (dammit-item i)) ,(childq (dammit-item j))))
;;                       (push j (dammit-after i))
;;                       (bump j (dammit-score i) nil)
;;                       ))))
;;       (mapcar 'dammit-item (sort items '< :key 'dammit-score)))))

(defun sort-boxes-for-placements (ip)
  "Return a list of MP boxes in the order they should be placed."
  (labels ((contained-p (b1 b2)
             (multiple-value-bind (b1-min b1-max) (parent-arg-inner-flanks b1)
               (multiple-value-bind (b2-min b2-max) (parent-arg-inner-flanks b2)
                 (and (null (descendants-of b1 (ip-multiparents ip)))
                      (null (descendants-of b2 (ip-multiparents ip)))
                      (< b1-min b2-min b2-max b1-max)
                      (notany (lambda (a) (> b2-min (geom:x a) b2-max))
                              (tree:parents b1))))))
           (sort-fn (a b)
             (let ((r (cond
                        ((tree:descendant-p a b)
                         nil)
                        ((tree:descendant-p b a)
                         :descendant)
                        ((contained-p a b)
                         nil)
                        ((contained-p b a)
                         :contained)
                        ((and (simple-multiparent-p a (ip-multiparents ip))
                              (not (simple-multiparent-p b (ip-multiparents ip))))
                         :simple)
                        (t nil))))
               ;;(print `(sort ,(childq a) ,(childq b) ,r))
             r)))
    ;; Order strongly affects how well the diagram will turn out.
    (let* ((boxes (copy-list (ip-multiparents ip)))
           (ordered (stable-sort (sort boxes '< :key 'tree:depth) #'sort-fn)))
      (print `(sorted ,(mapcar 'childq ordered)))
      ordered)))

(defun multi-parents-pass-2 (ip)
  "Fix up little things after all boxes have been placed."
  ;; align boxes over parents if possible.
  (loop with again = t
       while again do
       (setf again nil)
       (dolist (mp (ip-multiparents ip))
         (when (and (or (leaf-box-p mp)
                        (null (set-difference (ip-multiparents ip) (child-boxes mp))))
                    (notany (lambda (b)
                              (= (geom:centerx b) (geom:centerx mp)))
                            (parent-boxes mp)))
           (let ((p (find-if (lambda (b)
                               (and (geom:vertical-overlap-p b mp)
                                    (/= (geom:centerx b) (geom:centerx mp))))
                             (parent-boxes mp))))
             (when (and p
                        (every (lambda (b) (>= (geom:y b) (geom:y mp)))
                               (child-boxes p))
                        (not (find-if-on-tree (lambda (node)
                                                (unless (eq node mp)
                                                  (geom:overlap-p (geom:rect (- (geom:centerx p) (u:half (geom:width mp)))
                                                                             (geom:y mp)
                                                                             (geom:width mp) (geom:height mp))
                                                                  node)))
                                              (ip-root ip) :only-boxes t)))
               (setf again t)
               (move-tree mp (- (geom:centerx p) (u:half (geom:width mp))) (geom:y mp) t t)))))))

(defun place-multi-parents (ip)
  (let (solutions)
    (labels ((overlap (arg box)
               (not (or (< (geom:right box) (geom:x arg))
                        (> (geom:x box) (geom:right arg)))))
             (conflict (box challenger)
               (when (< (geom:y challenger) (geom:y box))
                 (let* ((args (loop for i in (tree:parents challenger)
                                 unless (tree:descendant-p i box)
                                 collect i))
                        (ret (some (lambda (arg) (overlap arg box)) args)))
                   ret)))
             (save-solution ()
               (push (list
                      (loop for i in (ip-boxes ip)
                         collect (make-multiparent-solution :box i :pos (geom:pt-from i)))
                      (evaluate-placement ip)
                      (random 100)
                      )
                     solutions))
             (restore-solution (set)
               (dolist (i set)
                 (move-multiparent-subtree (mps-box i) (geom:x (mps-pos i)) (geom:y (mps-pos i)) t)))
             (place (done rest)
               (if rest
                   (let* ((node (car rest))
                          (places (get-multi-parent-places node ip done)))
                     ;;(print `(places ,(childq node) ,places))
                     (loop for i in places
                        do (move-multiparent-subtree node (geom:x i) (geom:y i) t)
;;                         when (and (notany (lambda (b) (or (conflict node b)
;;                                                           (conflict b node))) done)
;;                                   (notany (lambda (b) (geom:overlap-p node b)) done)
;;                                   (notany (lambda (b) (geom:overlap-p node b)) (ip-regulars ip))
;;                                   (every (lambda (a) (> (geom:y a) (geom:bottom node))) (tree:parents node)))
                        do (place (cons node done) (cdr rest))))
                   (progn
                     (multi-parents-pass-2 ip)
                     (save-solution)
                     t))))
      (let ((boxes (sort-boxes-for-placements ip)))
        ;;(print `(simple-mp ,(mapcar 'childq (ip-simple-multiparents ip))))
        (loop for i in boxes for j from 0 do (setf (debug-text i) (list j (and (find i (ip-simple-multiparents ip)) t))))
        (place nil boxes))
      (if solutions
          (progn
            (print `(solns ,(length solutions) ,(mapcar 'second solutions)))
            ;;(print `(solns ,(mapcar 'second (sort (copy-list solutions) '< :key 'second))))
            (if *solution*
                (restore-solution (car (nth *solution* solutions)))
                (restore-solution (caar (sort solutions '< :key 'second))))
            ;; (print `(crossers ,(count-all-crossing-arrows root)))
            )
          (progn
            (warn "failed to place multi-parents in a conflict free arrangement.")
            (setf (spacing-failed-p (ip-diagram ip)) t))))))

(defun num-crossing-arrows (box boxes)
  (let ((args (tree:parents box)))
    ;;(print `(start))
    (loop for b in boxes
       sum (let ((amt (loop for i in (tree:parents b)
                         sum (loop for a in args
                                count (and (> (geom:y a) (geom:bottom b))
                                           (> (geom:y i) (geom:bottom box))
                                           (or (and (= (geom:y box) (geom:y b))
                                                    (or (and (< (geom:centerx box) (geom:centerx b))
                                                             (> (geom:centerx a) (geom:centerx i)))
                                                        (and (> (geom:centerx box) (geom:centerx b))
                                                             (< (geom:centerx a) (geom:centerx i)))))
                                               (and (< (geom:y box) (geom:y b))
                                                    (or (and (< (geom:centerx box) (geom:centerx b))
                                                             (< (geom:centerx a) (geom:centerx box))
                                                             (< (geom:centerx i) (geom:centerx b))
                                                             (> (geom:centerx a) (geom:centerx i)))
                                                        (and (> (geom:centerx box) (geom:centerx b))
                                                             (> (geom:centerx a) (geom:centerx box))
                                                             (> (geom:centerx i) (geom:centerx b))
                                                             (< (geom:centerx a) (geom:centerx i)))))
                                               (and (> (geom:y box) (geom:y b))
                                                    (or (and (> (geom:centerx box) (geom:centerx b))
                                                             (< (geom:centerx a) (geom:centerx box))
                                                             (< (geom:centerx i) (geom:centerx b))
                                                             (< (geom:centerx a) (geom:centerx i)))
                                                        (and (< (geom:centerx box) (geom:centerx b))
                                                             (> (geom:centerx a) (geom:centerx box))
                                                             (> (geom:centerx i) (geom:centerx b))
                                                             (> (geom:centerx a) (geom:centerx i)))))))))))
             ;;(print `(ok ,(length (tree:parents b)) ,amt ,(mapcar 'quantity (tree:children box)) ,(mapcar 'quantity (tree:children b))))
             amt))))

(defun space-below-box (boxes diagram box &optional in-box-units)
  "Returns the empty space between box and the box below it. if
IN-BOX-UNITS is non-NIL then return the value as the number of boxes
that could fit in the gap."
  (let* ((under (loop for b in (remove box boxes)
                     when (and (< (geom:y box) (geom:y b))
                               (not (or (> (geom:x box) (geom:right b))
                                        (< (geom:right box) (geom:x b)))))
                     collect b))
         (highest (loop for i in under minimize (geom:y i)))
         (y (- highest (geom:bottom box))))
    (if in-box-units
        (truncate y (+ (min-box-height diagram) (vpadding diagram)))
        y)))

(defun count-all-crossing-arrows (root)
  (let ((boxes (collect-on-tree (constantly t) root :only-boxes t)))
    (loop for i on boxes
       when (cdr i)
       sum (num-crossing-arrows (car i) (cdr i)))))

(defun count-arrows-through-boxes (ip)
  (loop for a in (remove-duplicates (apply 'append (mapcar 'tree:parents (ip-multiparents ip))))
     for child-boxes = (tree:children a)
     sum (loop for i in (collect-on-tree (constantly t) (ip-root ip) :only-boxes t)
            count (and
                   (< (geom:bottom i) (geom:y a))
                   ;; they overlap?
                   (not (or (< (geom:right a) (geom:x i))
                            (> (geom:x a) (geom:right i))))
                   (some (lambda (cb)
                           (< (geom:y cb) (geom:y i)))
                         child-boxes)))))

(defun count-overlapping-boxes (ip)
  (dolist (mp (ip-multiparents ip))
    (find-if-on-tree (lambda (node)
                       (unless (eq node mp)
                         (geom:overlap-p (geom:rect (- (geom:centerx mp) (u:half (geom:width mp)))
                                                    (geom:y mp)
                                                    (geom:width mp) (geom:height mp))
                                         node)))
                     (ip-root ip) :only-boxes t)))

(defun evaluate-placement (ip)
  "Return a numeric score representing how good a placement the
arrangement of multis and x boxes in ROOT is. A low score is good."
  (let ((crossing (loop for i on (ip-boxes ip)
                     when (cdr i)
                     sum (num-crossing-arrows (car i) (cdr i))))
        (columns (length (remove-duplicates (mapcar (lambda (b) (geom:centerx b)) (ip-boxes ip)) :test 'eql)))
        ;;(multi-rows (length (remove-duplicates (mapcar (lambda (b) (geom:y b)) (ip-multiparents ip)) :test 'eql)))
        (through (count-arrows-through-boxes ip))
        ;;(empty-under-multis (loop for b in (ip-multiparents ip) sum (space-below-box (ip-boxes ip) (ip-diagram ip) b t)))
        ;;(x-boxes-not-over-parent (loop for b in (ip-x-boxes ip) count (/= (geom:centerx b) (geom:centerx (tree:parent (first (tree:parents b)))))))
        ;;           (area (let ((d (tree-dimensions root nil nil)))
        ;;                   (truncate (* (geom:x d) (geom:y d))
        ;;                             (reduce '+ boxes :key 'geom:area))))
        )
    ;;(print `(eval ,crossing ,columns ,multi-rows ,empty-under-multis ,x-boxes-not-over-parent))
    ;;(print `(eval ,through))
    (+
     (* crossing 2)
     (* through 3)
     columns
;;      multi-rows
     )))

;;;;;;;

(defun align-leaf-nodes (root)
  (let ((leaves (collect-on-tree 'normal-leaf-box-p root)))
    (loop
       for l in (remove-if-not 'parent-box leaves)
       for p = (parent-box l)
       for o = (other-child-boxes p l)
       for x = (+ (geom:x p) (u:half (- (geom:width p) (geom:width l))))
       when (or (null o)
                (and
                 (every (lambda (b) (= (geom:y b) (geom:y l))) o)
                 (not (find-if-on-tree (lambda (node)
                                         (and (u:neq node l)
                                              (geom:overlap-p node (geom:rect x (geom:y l)
                                                                              (geom:width l) (geom:height l)))))
                                       root :only-boxes t))))
       do (move-tree l x (geom:y l) t))))

(defmethod space-tree ((diagram tree-view))
  (labels ((space (tree)
             (let ((ip (gen-info-pack tree diagram)))
               (dolist (b (ip-leaves ip))
                 (setf (debug-text b) "leaf"))
               (when (ip-multiparents ip)
                 (mapc #'space (ip-multiparents ip))
                 (place-multi-parents ip)))))
    ;; first pass
    (funcall-on-tree (lambda (x) (setf (geom:x x) 0 (geom:y x) 0) (space-node x diagram))
                     (d:root diagram)
                     :when :after)
    (funcall-on-tree (lambda (box)
                       (arrange-child-boxes box diagram))
                     (d:root diagram)
                     :when :after
                     :only-boxes t)
    ;; second pass: fix up multi parents
    (setf (spacing-failed-p diagram) nil)
    (space (d:root diagram))
    ;; third pass: adjust single parent leaf nodes
    (align-leaf-nodes (d:root diagram))))
